{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  P5Hs.Language.P5Doc
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Processing Doc combinators.
-- 
--------------------------------------------------------------------------------

module P5Hs.Language.P5Doc
  ( 
    comment
  , importStmt
  , hexDoc1
  , hexDoc3
  , hexDoc4
  , scalarAssignStmt
  , arrayData
  , arrayAssignStmt

  , funcall
  , funcallStmt
  , objcall
  , objcallStmt
  , forLoop
  , ifThen
  , ifThenElse
  , ifThenElseMulti
  , funDecl
  ) 
  where

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Data.Char
import Data.Word
import Numeric ( showHex )

comment :: String -> Doc
comment s = text $ "// " ++ s


importStmt :: String -> Doc
importStmt path = text "import" <+> text path <> semi

-- | Print as two byte word
hexDoc1 :: Word8 -> Doc
hexDoc1 i | i < 16      = text $ "0x0" ++ map toUpper (showHexString i)
          | otherwise   = text $ "0x" ++ map toUpper (showHexString i)

hexDoc3 :: Word8 -> Word8 -> Word8 -> Doc
hexDoc3 a b c = text $ "0x" ++ fn a ++ fn b ++ fn c
  where
    fn i | i < 16       = '0' : map toUpper (showHexString i)
         | otherwise    = map toUpper $ showHexString i

hexDoc4 :: Word8 -> Word8 -> Word8 -> Word8 -> Doc
hexDoc4 a b c d = text $ "0x" ++ fn a ++ fn b ++ fn c ++ fn d
  where
    fn i | i < 16       = '0' : map toUpper (showHexString i)
         | otherwise    = map toUpper $ showHexString i


scalarAssignStmt :: Doc -> Doc -> Doc
scalarAssignStmt name val = 
    name <+> equals <+> val <> semi


arrayData :: [Doc] -> Doc
arrayData xs = braces $ commaSpace xs


arrayAssignStmt :: Doc -> Doc -> Doc -> Doc
arrayAssignStmt name ix val = 
    name <> char '[' <> ix <> char ']' <+> equals <+> val <> semi


-- | Without terminating semi.
--
funcall :: String -> [Doc] -> Doc
funcall name args = text name <> parens (commaSpace args)

-- | With terminating semi.
--
funcallStmt :: String -> [Doc] -> Doc
funcallStmt name args = funcall name args <> semi


-- | Without terminating semi.
--
objcall :: String -> String -> [Doc] -> Doc
objcall obj method args = funcall (obj ++ "." ++ method) args

-- | With terminating semi.
--
objcallStmt :: String -> String -> [Doc] -> Doc
objcallStmt obj method args = funcallStmt (obj ++ "." ++ method) args


forLoop :: (Doc,Doc,Doc) -> Doc -> Doc
forLoop (a,b,c) body = 
    text "for" <+> parens (semiSpace [a,b,c]) <+> rbrace
      $+$ nest 2 body
      $+$ lbrace

ifThen :: Doc -> Doc -> Doc
ifThen e t = 
    text "if" <+> e <+> lbrace 
      $+$ body 
      $+$ rbrace
  where
   body = nest 2 t

ifThenElse :: Doc -> Doc -> Doc -> Doc
ifThenElse e t f = 
   text "if" <+> e <+> lbrace 
     $+$ tbody 
     $+$ rbrace <+> text "else" <+> lbrace
     $+$ fbody
     $+$ rbrace
  where
   tbody = nest 2 t
   fbody = nest 2 f


ifThenElseMulti :: Doc -> Doc -> [(Doc,Doc)]-> Doc -> Doc
ifThenElseMulti e t []   f = ifThenElse e t f
ifThenElseMulti e t alts f = 
   text "if" <+> e <+> lbrace 
     $+$ tbody 
     $+$ (vcat $ map alt1 alts)
     $+$ rbrace <+> text "else" <+> lbrace
     $+$ fbody
     $+$ rbrace
  where
   tbody = nest 2 t
   fbody = nest 2 f
   alt1  = \(c,body) -> rbrace <+> text "else if" <+> c <+> lbrace 
                               $+$ (nest 2 body)

funDecl :: Doc -> String -> [Doc] -> Doc -> Doc
funDecl ret name args body = 
    ret <+> text name <> parens (commaSpace args) <+> lbrace
      $+$ nest 2 body
      $+$ rbrace

--------------------------------------------------------------------------------
-- Helpers

-- textS :: ShowS -> Doc
-- textS = text . ($"")

showHexString :: (Integral a, Show a) => a -> String
showHexString = ($ "") . showHex

commaSpace :: [Doc] -> Doc
commaSpace []     = empty
commaSpace [d]    = d
commaSpace (d:ds) = step d ds
  where
    step ac [] = ac
    step ac (x:xs) = step (ac <> comma <+> x) xs

semiSpace :: [Doc] -> Doc
semiSpace []     = empty
semiSpace [d]    = d
semiSpace (d:ds) = step d ds
  where
    step ac [] = ac
    step ac (x:xs) = step (ac <> semi <+> x) xs
